home *** CD-ROM | disk | FTP | other *** search
/ Disc to the Future 2 / Disc to the Future Part II Programmer's Reference (Wayzata Technology)(6013)(1992).bin / MAC / MPW_TOOL / TOOLS / TOOLS_WI / ICON_8 / ICONX_FO / OREF.C < prev    next >
Text File  |  1990-03-02  |  16KB  |  577 lines
  1. /*
  2.  * File: oref.c
  3.  *  Contents: bang, random, sect, subsc
  4.  */
  5.  
  6. #include "::h:config.h"
  7. #include "::h:rt.h"
  8. #include "rproto.h"
  9.  
  10. #ifdef PreProcess
  11. /* include(../M4/ops.m4) /* */
  12. /* */
  13. #endif                    /* PreProcess */
  14.  
  15. /*
  16.  * !x - generate successive values from object x.
  17.  */
  18.  
  19. OpDcl(bang,1,"!")
  20.    {
  21.    register word i, j, slen, rlen;
  22.    register union block *bp;
  23.    register dptr dp;
  24.    register char *sp;
  25.    int typ1;
  26.    char sbuf[MaxCvtLen];
  27.    FILE *fd;
  28.  
  29.    Arg2 = Arg1;
  30.  
  31.    if (DeRef(Arg1) == Error) 
  32.       RunErr(0, NULL);
  33.    if ((typ1 = cvstr(&Arg1, sbuf)) != CvtFail) {
  34.       /*
  35.        * A string is being banged.
  36.        */
  37.       i = 1;
  38.       while (i <= StrLen(Arg1)) {
  39.          /*
  40.           * Loop through the string using i as an index.
  41.           */
  42.          if (typ1 == Cvt) {
  43.             /*
  44.              * Arg1 was converted to a string, thus, the resulting string
  45.              *    cannot be modified and a trapped variable is not needed.
  46.              *    Make a one-character string out of the next character
  47.              *    in Arg1 and suspend it.
  48.              */
  49.             if (strreq((word)1) == Error) 
  50.                RunErr(0, NULL);
  51.             StrLen(Arg0) = 1;
  52.             StrLoc(Arg0) = alcstr(StrLoc(Arg1)+i-1, (word)1);
  53.             Suspend;
  54.             }
  55.          else {
  56.             /*
  57.              * Arg1 is a string and thus a trapped variable must be made
  58.              *    for the one character string being suspended.
  59.              */
  60.             if (blkreq((word)sizeof(struct b_tvsubs)) == Error) 
  61.                RunErr(0, NULL);
  62.             mksubs(&Arg2, &Arg1, i, (word)1, &Arg0);
  63.             Suspend;
  64.             Arg1 = Arg2;
  65.             if (DeRef(Arg1) == Error) 
  66.                RunErr(0, NULL);
  67.             if (!Qual(Arg1)) 
  68.                RunErr(103, &Arg1);
  69.             }
  70.          i++;
  71.          }
  72.       }
  73.    else {
  74.       /*
  75.        * Arg1 is not a string.
  76.        */
  77.       switch (Type(Arg1)) {
  78.          case T_List:
  79.             /*
  80.              * Arg1 is a list.  Chain through each list element block and for
  81.              *    each one, suspend with a variable pointing to each
  82.              *    element contained in the block.
  83.              */
  84.             bp = BlkLoc(Arg1);
  85.             for (bp = bp->list.listhead; bp != NULL; bp = bp->lelem.listnext) {
  86.                for (i = 0; i < bp->lelem.nused; i++) {
  87.                   j = bp->lelem.first + i;
  88.                   if (j >= bp->lelem.nslots)
  89.                      j -= bp->lelem.nslots;
  90.                   dp = &bp->lelem.lslots[j];
  91.                   Arg0.dword = D_Var + ((word *)dp - (word *)bp);
  92.                   VarLoc(Arg0) = (dptr)bp;
  93.           BlkLoc(Arg1) = bp;     /* save in Arg1 since bp is untended */
  94.                   Suspend;
  95.                   bp = BlkLoc(Arg1);     /* bp is untended, must reset */
  96.                   }
  97.                }
  98.             break;
  99.  
  100.  
  101.          case T_File:
  102.             /*
  103.              * Arg1 is a file.  Read the next line into the string space
  104.              *    and suspend the newly allocated string.
  105.              */
  106.             fd = BlkLoc(Arg1)->file.fd;
  107.             if ((BlkLoc(Arg1)->file.status & Fs_Read) == 0) 
  108.                RunErr(212, &Arg1);
  109.         for (;;) {
  110.            StrLen(Arg0) = 0;
  111.            do {
  112.           if ((slen = getstrg(sbuf,MaxCvtLen,fd)) == -1)
  113.                      Fail;
  114.           rlen = slen < 0 ? (word)MaxCvtLen : slen;
  115.                   if (strreq(rlen) == Error) 
  116.                      RunErr(0, NULL);
  117.           sp = alcstr(sbuf,rlen);
  118.           if (StrLen(Arg0) == 0)
  119.                      StrLoc(Arg0) = sp;
  120.           StrLen(Arg0) += rlen;
  121.           } while (slen < 0);
  122.                   Suspend;
  123.                }
  124.             break;
  125.  
  126.          case T_Table:
  127.             /*
  128.              * Arg1 is a table.  Generate the element values.
  129.              */
  130.             MakeInt(2, &Arg2);        /* indicate that we want the values */
  131.             Forward(hgener);        /* go to the hash generator */
  132.  
  133.          case T_Set:
  134.             /*
  135.              * Arg1 is a set.  Generate the element values.
  136.              */
  137.             MakeInt(0, &Arg2);        /* indicate that we want set elements */
  138.             Forward(hgener);        /* go to the hash generator */
  139.  
  140.          case T_Record:
  141.             /*
  142.              * Arg1 is a record.  Loop through the fields and suspend
  143.              *    a variable pointing to each one.
  144.              */
  145.             bp = BlkLoc(Arg1);
  146.             j = bp->record.recdesc->proc.nfields;
  147.             for (i = 0; i < j; i++) {
  148.                dp = &bp->record.fields[i];
  149.                Arg0.dword = D_Var + ((word *)dp - (word *)bp);
  150.                VarLoc(Arg0) = (dptr)bp;
  151.                Suspend;
  152.                bp = BlkLoc(Arg1);        /* bp is untended, must reset */
  153.                }
  154.             break;
  155.  
  156.          default: /* This object can not be compromised. */
  157.             RunErr(116, &Arg1);
  158.          }
  159.       }
  160.  
  161.    /*
  162.     * Eventually fail.
  163.     */
  164.    Fail;
  165.    }
  166.  
  167. #define RandVal (RanScale*(k_random=(RandA*k_random+RandC)&MaxLong))
  168.  
  169. /*
  170.  * ?x - produce a randomly selected element of x.
  171.  */
  172.  
  173. OpDcl(random,1,"?")
  174.    {
  175.    register word val, i, j, n;
  176.    register union block *bp, *ep;
  177.    struct b_slots *seg;
  178.    char sbuf[MaxCvtLen];
  179.    dptr dp;
  180.    double rval;
  181.  
  182.    Arg2 = Arg1;
  183.    if (DeRef(Arg1) == Error) 
  184.       RunErr(0, NULL);
  185.  
  186.    if (Qual(Arg1)) {
  187.       /*
  188.        * Arg1 is a string, produce a random character in it as the result.
  189.        *  Note that a substring trapped variable is returned.
  190.        */
  191.       if ((val = StrLen(Arg1)) <= 0)
  192.          Fail;
  193.       if (blkreq((word)sizeof(struct b_tvsubs)) == Error) 
  194.          RunErr(0, NULL);
  195.       rval = RandVal;            /* This form is used to get around */
  196.       rval *= val;            /* a bug in a certain C compiler */
  197.       mksubs(&Arg2, &Arg1, (word)rval + 1, (word)1, &Arg0);
  198.       Return;
  199.       }
  200.  
  201.    switch (Type(Arg1)) {
  202.       case T_Cset:
  203.          /*
  204.           * Arg1 is a cset.  Convert it to a string, select a random character
  205.           *  of that string and return it.  Note that a substring trapped
  206.           *  variable is not needed.
  207.           */
  208.          cvstr(&Arg1, sbuf);
  209.          if ((val = StrLen(Arg1)) <= 0)
  210.             Fail;
  211.          if (strreq((word)1) == Error) 
  212.             RunErr(0, NULL);
  213.          StrLen(Arg0) = 1;
  214.          rval = RandVal;
  215.          rval *= val;
  216.          StrLoc(Arg0) = alcstr(StrLoc(Arg1)+(word)rval, (word)1);
  217.          Return;
  218.  
  219.  
  220.       case T_List:
  221.          /*
  222.           * Arg1 is a list.  Set i to a random number in the range [1,*Arg1],
  223.           *  failing if the list is empty.
  224.           */
  225.          bp = BlkLoc(Arg1);
  226.          val = bp->list.size;
  227.          if (val <= 0)
  228.             Fail;
  229.          rval = RandVal;
  230.          rval *= val;
  231.          i = (word)rval + 1;
  232.          j = 1;
  233.          /*
  234.           * Work down chain list of list blocks and find the block that
  235.           *  contains the selected element.
  236.           */
  237.          bp = bp->list.listhead;
  238.          while (i >= j + bp->lelem.nused) {
  239.             j += bp->lelem.nused;
  240.             bp = bp->lelem.listnext;
  241.             if (bp == NULL)
  242.                syserr("list reference out of bounds in random");
  243.             }
  244.          /*
  245.           * Locate the appropriate element and return a variable
  246.           * that points to it.
  247.           */
  248.          i += bp->lelem.first - j;
  249.          if (i >= bp->lelem.nslots)
  250.             i -= bp->lelem.nslots;
  251.          dp = &bp->lelem.lslots[i];
  252.          Arg0.dword = D_Var + ((word *)dp - (word *)bp);
  253.          VarLoc(Arg0) = (dptr)bp;
  254.          Return;
  255.  
  256.       case T_Table:
  257.       case T_Set:
  258.           /*
  259.            * Arg1 is a table or a set.  Set n to a random number in the range
  260.            *  [1,*Arg1], failing if the structure is empty.
  261.            */
  262.          bp = BlkLoc(Arg1);
  263.          val = bp->table.size;
  264.          if (val <= 0)
  265.             Fail;
  266.          rval = RandVal;
  267.          rval *= val;
  268.          n = (word)rval + 1;
  269.          /*
  270.           * Walk down the hash chains to find and return the n'th element.
  271.           */
  272.          for (i = 0; i < HSegs && (seg = bp->table.hdir[i]) != NULL; i++)
  273.             for (j = segsize[i] - 1; j >= 0; j--)
  274.                for (ep = seg->hslots[j]; ep != NULL; ep = ep->telem.clink)
  275.                   if (--n <= 0) {
  276.                      if (Type(Arg1) == T_Set) {
  277.                         /*
  278.                          * For a set, return the element value.
  279.                          */
  280.                         Arg0 = ep->selem.setmem;
  281.                         }
  282.                      else {
  283.                         /*
  284.                          * For a table, return a variable pointing to the
  285.                          *  selected element.
  286.                          */
  287.                         dp = &ep->telem.tval;
  288.                         Arg0.dword = D_Var + ((word *)dp - (word *)bp);
  289.                         VarLoc(Arg0) = (dptr)bp;
  290.                         }
  291.                      Return;
  292.                      }
  293.  
  294.       case T_Record:
  295.          /*
  296.           * Arg1 is a record.  Set val to a random number in the range
  297.           *  [1,*Arg1] (*Arg1 is the number of fields), failing if the
  298.           *  record has no fields.
  299.           */
  300.          bp = BlkLoc(Arg1);
  301.          val = bp->record.recdesc->proc.nfields;
  302.          if (val <= 0)
  303.             Fail;
  304.          /*
  305.           * Locate the selected element and return a variable
  306.           * that points to it
  307.           */
  308.             rval = RandVal;
  309.             rval *= val;
  310.             dp = &bp->record.fields[(word)rval];
  311.             Arg0.dword = D_Var + ((word *)dp - (word *)bp);
  312.             VarLoc(Arg0) = (dptr)bp;
  313.             Return;
  314.  
  315. #ifdef LargeInts
  316.       case T_Bignum:
  317.      if (bigrand(&Arg1, &Arg0) == Error)  /* alcbignum failed */
  318.         RunErr(0, NULL);
  319.      Return;
  320. #endif                    /* LargeInts */
  321.  
  322.       default:
  323.          /*
  324.           * Try converting it to an integer
  325.           */
  326.       switch (cvint(&Arg1)) {
  327.  
  328.          case T_Integer:
  329.             /*
  330.              * Arg1 is an integer, be sure that it's non-negative.
  331.              */
  332.             val = (word)IntVal(Arg1);
  333.             if (val < 0)
  334.                RunErr(205, &Arg1);
  335.  
  336.             /*
  337.              * val contains the integer value of Arg1.    If val is 0, return
  338.              *    a real in the range [0,1], else return an integer in the
  339.              *    range [1,val].
  340.              */
  341.             if (val == 0) {
  342.                rval = RandVal;
  343.                if (makereal(rval, &Arg0) == Error) 
  344.                   RunErr(0, NULL);
  345.                }
  346.             else {
  347.                rval = RandVal;
  348.                rval *= val;
  349.                MakeInt((long)rval + 1, &Arg0);
  350.                }
  351.             Return;
  352.  
  353.          default:
  354.             /*
  355.              * Arg1 is of a type for which random generation is not supported
  356.              */
  357.             RunErr(113, &Arg1);
  358.             }
  359.          }
  360.    }
  361.  
  362. /*
  363.  * x[i:j] - form a substring or list section of x.
  364.  */
  365.  
  366. OpDcl(sect,3,"[:]")
  367.    {
  368.    register word i, j, t;
  369.    int typ1;
  370.    char sbuf[MaxCvtLen];
  371.  
  372.    if (blkreq((word)sizeof(struct b_tvsubs)) == Error) 
  373.       RunErr(0, NULL);
  374.  
  375.    if (cvint(&Arg2) == CvtFail) 
  376.       RunErr(101, &Arg2);
  377.    if (cvint(&Arg3) == CvtFail) 
  378.       RunErr(101, &Arg3);
  379.  
  380.    Arg4 = Arg1;
  381.    if (DeRef(Arg1) == Error) 
  382.       RunErr(0, NULL);
  383.  
  384.    if (Arg1.dword == D_List) {
  385.       i = cvpos(IntVal(Arg2), BlkLoc(Arg1)->list.size);
  386.       if (i == CvtFail)
  387.          Fail;
  388.       j = cvpos(IntVal(Arg3), BlkLoc(Arg1)->list.size);
  389.       if (j == CvtFail)
  390.          Fail;
  391.       if (i > j) {
  392.          t = i;
  393.          i = j;
  394.          j = t;
  395.          }
  396.       if (cplist(&Arg1, &Arg0, i, j) == Error) 
  397.          RunErr(0, NULL);
  398.       Return;
  399.       }
  400.  
  401.    if ((typ1 = cvstr(&Arg1, sbuf)) == CvtFail) 
  402.       RunErr(110, &Arg1);
  403.  
  404.    i = cvpos(IntVal(Arg2), StrLen(Arg1));
  405.    if (i == CvtFail)
  406.       Fail;
  407.    j = cvpos(IntVal(Arg3), StrLen(Arg1));
  408.    if (j == CvtFail)
  409.       Fail;
  410.    if (i > j) {             /* convert section to substring */
  411.       t = i;
  412.       i = j;
  413.       j = t - j;
  414.       }
  415.    else
  416.       j = j - i;
  417.  
  418.    if (typ1 == Cvt) {
  419.       /*
  420.        * A string was created - just return a string
  421.        */
  422.       if (strreq(j) == Error) 
  423.          RunErr(0, NULL);
  424.       StrLen(Arg0) = j;
  425.       StrLoc(Arg0) = alcstr(StrLoc(Arg1)+i-1, j);
  426.       }
  427.    else                 /* else make a substring tv */
  428.       mksubs(&Arg4, &Arg1, i, j, &Arg0);
  429.    Return;
  430.    }
  431.  
  432. /*
  433.  * x[y] - access yth character or element of x.
  434.  */
  435.  
  436. OpDcl(subsc,2,"[]")
  437.    {
  438.    register word i, j;
  439.    register union block *bp;
  440.    register uword hn;
  441.    int typ1, res;
  442.    dptr dp;
  443.    union block **dp1;
  444.    char sbuf[MaxCvtLen];
  445.  
  446.    /*
  447.     * Make a copy of Arg1.
  448.     */
  449.    Arg3 = Arg1;
  450.  
  451.    if (DeRef(Arg1) == Error) 
  452.       RunErr(0, NULL);
  453.    if ((typ1 = cvstr(&Arg1, sbuf)) != CvtFail) {
  454.       /*
  455.        * Arg1 is a string, make sure that Arg2 is an integer.
  456.        */
  457.       if (cvint(&Arg2) == CvtFail) 
  458.          RunErr(101, &Arg2);
  459.  
  460.       /*
  461.        * Convert Arg2 to a position in Arg1 and fail if the position is out
  462.        *  of bounds.
  463.        */
  464.       i = cvpos(IntVal(Arg2), StrLen(Arg1));
  465.       if (i == CvtFail || i > StrLen(Arg1))
  466.          Fail;
  467.       if (typ1 == Cvt) {
  468.          /*
  469.           * Arg1 was converted to a string, so it cannot be assigned back into.
  470.           *  Just return a string containing the selected character.
  471.           */
  472.          if (strreq((word)1) == Error) 
  473.             RunErr(0, NULL);
  474.          StrLen(Arg0) = 1;
  475.          StrLoc(Arg0) = alcstr(StrLoc(Arg1)+i-1, (word)1);
  476.          }
  477.       else {
  478.          /*
  479.           * Arg1 is a string, make a substring trapped variable for the one
  480.           *  character substring selected and return it.
  481.           */
  482.          if (blkreq((word)sizeof(struct b_tvsubs)) == Error) 
  483.             RunErr(0, NULL);
  484.          mksubs(&Arg3, &Arg1, i, (word)1, &Arg0);
  485.          }
  486.       Return;
  487.       }
  488.  
  489.    /*
  490.     * Arg1 is not a string or convertible to one, see if it's an aggregate.
  491.     */
  492.    switch (Type(Arg1)) {
  493.       case T_List:
  494.          /*
  495.           * Make sure that Arg2 is an integer and that the
  496.           *  subscript is in range.
  497.           */
  498.          if (cvint(&Arg2) == CvtFail) 
  499.             RunErr(101, &Arg2);
  500.          i = cvpos(IntVal(Arg2), BlkLoc(Arg1)->list.size);
  501.          if (i == CvtFail || i > BlkLoc(Arg1)->list.size)
  502.             Fail;
  503.  
  504.          /*
  505.           * Locate the list-element block containing the desired
  506.           *  element.
  507.           */
  508.          bp = BlkLoc(Arg1)->list.listhead;
  509.          j = 1;
  510.          while (bp != NULL && i >= j + bp->lelem.nused) {
  511.             j += bp->lelem.nused;
  512.             bp = bp->lelem.listnext;
  513.             }
  514.  
  515.          /*
  516.           * Locate the desired element and return a pointer to it.
  517.           */
  518.          i += bp->lelem.first - j;
  519.          if (i >= bp->lelem.nslots)
  520.             i -= bp->lelem.nslots;
  521.          dp = &bp->lelem.lslots[i];
  522.          Arg0.dword = D_Var + ((word *)dp - (word *)bp);
  523.          VarLoc(Arg0) = (dptr)bp;
  524.          Return;
  525.  
  526.       case T_Table:
  527.          /*
  528.           * Arg1 is a table.  Locate the appropriate bucket
  529.           *  based on the hash value.
  530.           */
  531.          if (blkreq((word)sizeof(struct b_tvtbl)) == Error) 
  532.             RunErr(0, NULL);
  533.          hn = hash(&Arg2);
  534.          dp1 = memb(BlkLoc(Arg1), &Arg2, hn, &res);
  535.          if (res == 1) {
  536.             bp = *dp1;
  537.             dp = &bp->telem.tval;
  538.             Arg0.dword = D_Var + ((word *)dp - (word *)bp);
  539.             VarLoc(Arg0) = (dptr)bp;
  540.             }
  541.          else {
  542.             /*
  543.              * Arg1[Arg2] is not in the table, make a table element trapped
  544.              *  variable and return it as the result.
  545.              */
  546.             Arg0.dword = D_Tvtbl;
  547.             BlkLoc(Arg0) = (union block *)alctvtbl(&Arg1, &Arg2, hn);
  548.             }
  549.          Return;
  550.  
  551.       case T_Record:
  552.          /*
  553.           * Arg1 is a record.  Convert Arg2 to an integer and be sure that it
  554.           *  it is in range as a field number.
  555.           */
  556.          if (cvint(&Arg2) == CvtFail) 
  557.             RunErr(101, &Arg2);
  558.          bp = BlkLoc(Arg1);
  559.          i = cvpos(IntVal(Arg2), (word)(bp->record.recdesc->proc.nfields));
  560.          if (i == CvtFail || i > bp->record.recdesc->proc.nfields)
  561.             Fail;
  562.          /*
  563.           * Locate the appropriate field and return a pointer to it.
  564.           */
  565.          dp = &bp->record.fields[i-1];
  566.          Arg0.dword = D_Var + ((word *)dp - (word *)bp);
  567.          VarLoc(Arg0) = (dptr)bp;
  568.          Return;
  569.  
  570.       default:
  571.          /*
  572.           * Arg1 is of a type that cannot be subscripted.
  573.           */
  574.          RunErr(114, &Arg1);
  575.       }
  576.    }
  577.